
'        This is a part of the source code for Pro/DESKTOP.
'        Copyright (C) 1998-1999 Parametric Technology Corporation.
'        All rights reserved.

'VBA script to create wheel

Dim app As Object

Sub Wheel()

    Set app = CreateObject("ProDESKTOP.Application")
    
    app.SetVisible True
    
    'Take the helm
    Dim api As helm
    Set api = app.TakeHelm
    
    Dim part As PartDocument
    Set part = app.NewPart
    
    'Get Active workplane and sketch
    Dim ActiveWorkplane As aWorkplane
    Set ActiveWorkplane = part.GetActiveWorkplane
    ActiveWorkplane.SetName ("Profile")
    Set Profile = part.GetActiveSketch
    
    'Create Profile
    
    Dim vector1 As zVector
    Dim vector2 As zVector
    Dim vector3 As zVector
    Dim vector4 As zVector
    Dim vector5 As zVector
    Dim vector6 As zVector
    Dim vector7 As zVector
    Dim vector8 As zVector
    Dim vector9 As zVector
    Dim vector10 As zVector
    Dim vector11 As zVector
    Dim vector12  As zVector
    Dim vector13 As zVector
    Dim vector14 As zVector
    
    
    Set vector1 = app.GetClass("Vector").CreateVector(-0.07915, 0.0625, 0#)
    Set vector2 = app.GetClass("Vector").CreateVector(-0.07915, 0.0815, 0#)
    Set vector3 = app.GetClass("Vector").CreateVector(-0.0125, 0.105, 0#)
    Set vector4 = app.GetClass("Vector").CreateVector(-0.0125, 0.155, 0#)
    Set vector5 = app.GetClass("Vector").CreateVector(-0.069, 0.1725, 0#)
    Set vector6 = app.GetClass("Vector").CreateVector(-0.069, 0.1875, 0#)
    Set vector7 = app.GetClass("Vector").CreateVector(0.069, 0.1875, 0#)
    Set vector8 = app.GetClass("Vector").CreateVector(0.069, 0.1725, 0#)
    Set vector9 = app.GetClass("Vector").CreateVector(0.0125, 0.155, 0#)
    Set vector10 = app.GetClass("Vector").CreateVector(0.0125, 0.105, 0#)
    Set vector11 = app.GetClass("Vector").CreateVector(0.07915, 0.0815, 0#)
    Set vector12 = app.GetClass("Vector").CreateVector(0.07915, 0.0625, 0#)
    Set vector13 = app.GetClass("Vector").CreateVector(-0.1, 0#, 0#)
    Set vector14 = app.GetClass("Vector").CreateVector(0.1, 0#, 0#)
    
    Set line1 = line(vector1, vector2, Profile)
    Set line2 = line(vector2, vector3, Profile)
    Set line3 = line(vector3, vector4, Profile)
    Set line4 = line(vector4, vector5, Profile)
    Set line5 = line(vector5, vector6, Profile)
    Set line6 = line(vector6, vector7, Profile)
    Set line7 = line(vector7, vector8, Profile)
    Set line8 = line(vector8, vector9, Profile)
    Set line9 = line(vector9, vector10, Profile)
    Set line10 = line(vector10, vector11, Profile)
    Set line11 = line(vector11, vector12, Profile)
    Set line12 = line(vector12, vector1, Profile)
    
    'Create a new sketch for the axis
    
    Dim Axis As aSketch
    Set Axis = ActiveWorkplane.CreateSketch("axis")
    Set line13 = line(vector13, vector14, Axis)
     
    'Revolve profile
    Dim revolution1 As aRevolution
    Set revolution1 = app.GetClass("Revolution").CreateRevolution(part.GetDesign, Profile, Axis, 6.28, 0, 0, 1, 0)
    revolution1.SetName ("Wheel")
    part.UpdateDesign
     
    api.CommitCalls "Wheel", pause
    
    Rem Save the Assembly
    Dim bFileClosed As Boolean
    bFileClosed = part.Close("c:\Wheel.des", True)
    
    On Error GoTo SaveErr
    ret = part.Close(pathName, True)
    On Error GoTo 0
    
    Exit Sub
    
SaveErr:
            MsgBox "Could not Save the Active Part", vbExclamation, "Error"
            Exit Sub
            
End Sub

'-------------------------------------------------------------------------------------------

'Sub Spindle.
'Creates a spindle for the spindle wheel assembly.

Sub spindle()

    Dim app As Object
    Set app = CreateObject("ProDESKTOP.Application")
    
    app.SetVisible True
    
    'Take the helm
    Dim api As helm
    Set api = app.TakeHelm
    
    Dim part As PartDocument
    Set part = app.NewPart
    
    Dim workplane As aWorkplane
    Dim Workplane1 As aWorkplane
    Dim sketch As aSketch
    
    Set workplane = part.GetActiveWorkplane
    Set sketch = part.GetActiveSketch
    
    
    Dim line1 As aLine
    Dim line2 As aLine
    Dim line3 As aLine
    Dim line4 As aLine
    Dim line5 As aLine
    Dim line6 As aLine
    Dim line7 As aLine
    Dim line8 As aLine
    Dim line13 As aLine
    Dim line14 As aLine
    
    Dim vector1 As zVector
    Dim vector2 As zVector
    Dim vector3 As zVector
    Dim vector4 As zVector
    Dim vector5 As zVector
    Dim vector6 As zVector
    Dim vector7 As zVector
    Dim vector8 As zVector
    Dim vector9 As zVector
    Dim vector10 As zVector
    Dim vector11 As zVector
    Dim vector12  As zVector
    Dim vector13 As zVector
    Dim vector14 As zVector
    
    
    Set vector1 = app.GetClass("Vector").CreateVector(-0.15, 0.02, 0#)
    Set vector2 = app.GetClass("Vector").CreateVector(-0.15, 0.0375, 0#)
    Set vector3 = app.GetClass("Vector").CreateVector(-0.07915, 0.0375, 0#)
    Set vector4 = app.GetClass("Vector").CreateVector(-0.07915, 0.0625, 0#)
    Set vector5 = app.GetClass("Vector").CreateVector(0.07915, 0.0625, 0#)
    Set vector6 = app.GetClass("Vector").CreateVector(0.07915, 0.0375, 0#)
    Set vector7 = app.GetClass("Vector").CreateVector(0.15, 0.0375, 0#)
    Set vector8 = app.GetClass("Vector").CreateVector(0.15, 0.02, 0#)
    
    'Create profile
     Set line1 = line(vector1, vector2, sketch)
     Set line2 = line(vector2, vector3, sketch)
     Set line3 = line(vector3, vector4, sketch)
     Set line4 = line(vector4, vector5, sketch)
     Set line5 = line(vector5, vector6, sketch)
     Set line6 = line(vector6, vector7, sketch)
     Set line7 = line(vector7, vector8, sketch)
     Set line8 = line(vector8, vector1, sketch)
     
    'Create New sketch
    Dim axisSketch As aSketch
    sketchName = "axisSketch"
    Set axisSketch = workplane.CreateSketch(sketchName)
    
    Set vector13 = app.GetClass("Vector").CreateVector(-0.1, 0#, 0#)
    Set vector14 = app.GetClass("Vector").CreateVector(0.1, 0#, 0#)
    Set line13 = line(vector13, vector14, axisSketch)
    
    'Create Revolution
    'Revolve profile
     
    Dim revolution1 As aRevolution
     
    'This script assumes that 0 indicates Add Material, 1 for subtrace and 2 for intersect
     
    Set revolution1 = app.GetClass("Revolution").CreateRevolution(part.GetDesign, sketch, axisSketch, 6.28, 0, 0, 1, 0)
    revolution1.SetName ("Spindle")
    part.UpdateDesign
    
    Dim bFileClosed As Boolean
    bFileClosed = part.Close("c:\Spindle.des", True)
        
    api.CommitCalls "Spindle", pause

End Sub

'-------------------------------------------------------------------------------------------

Function menuWheelSpindleAssembly()

    Dim app As Object
    Set app = CreateObject("ProDESKTOP.Application")
    
    app.SetVisible True
    
    Dim wheelComponent As aGraphic
    Dim spindleComponent As aGraphic
    
    Rem Create  a wheel and a spindle
    Call Wheel
    Call spindle
    
    Dim helmObject As helm
    Set helmObject = app.TakeHelm
    
    
    Rem Add component
    Dim part As PartDocument
    Set part = app.NewPart
    Set wheelComponent = AddComponent("c:\wheel.des", part)
    Set spindleComponent = AddComponent("c:\spindle.des", part)
    
    helmObject.CommitCalls "UpdateView", False
    
    
    Rem Align Center Axes
    helmObject.CommitCalls "UpdateView", False
    
    MsgBox ("Select one Circular Edge of Spindle and one Circular Edge of Wheel for Center Axis Constraint")
    helmObject.CommitCalls "Select Edges", True
    Dim selectionSet1 As ObjectSet
    Set selectionSet1 = part.GetSelection("Topology")
    
    Dim selectionSetIt1 As Iterator
    Set selectionSetIt1 = app.GetClass("it").CreateAObjectIt(selectionSet1)
    
    Dim topy1 As aTopology
    Dim topy2 As aTopology
    Set topy1 = selectionSetIt1.start
    Set topy2 = selectionSetIt1.Next
    
    
    Set centerAxesCls = app.GetClass("CenterAxes")
    Dim mc As zCenterAxes
    Set mc = centerAxesCls.CreateCenterAxes(topy1, topy2)
    
     
    Dim ins As aDesignInstance
    Set ins = topy1.GetParent("DesignInstance")
    ins.AddMatingCondition mc
    
    helmObject.CommitCalls "centerAxes", False
    
    
    
    Rem Align Planes
    helmObject.CommitCalls "UpdateView", False
    
SELECTFACES:
         MsgBox ("Select a Planar face of Spindle and a Planar face of Wheel for Align Planes Constraint")
    
         helmObject.CommitCalls "Selection", True
    
    Set selectionSet = part.GetSelection("Topology")
    
    Set selectionSetIt = app.GetClass("it").CreateAObjectIt(selectionSet)
    
    Set firstTopology = selectionSetIt.start
    
    Set secondTopology = selectionSetIt.Next
    
    Dim blnFirstFace As Boolean
    Dim blnSecondFace As Boolean
    blnFirstFace = firstTopology.GetGeometricForm.IsA("Plane")
    blnSecondFace = secondTopology.GetGeometricForm.IsA("Plane")
      
    If Not (blnFirstFace And blnSecondFace) Then
        GoTo SELECTFACES
    End If
      
    
    
    If (secondTopology.IsDependentOn(firstTopology)) Then
    Set temp = firstTopology
    Set firstTopology = secondTopology
    Set secondTopology = temp
    End If
    
    
    Dim abutPlanesCls As AbutPlanesClass
    Set abutPlanesCls = app.GetClass("AbutPlanes")
    Dim abutPlanes As zAbutPlanes
    
    Set abutPlanes = abutPlanesCls.CreateAbutPlanes(part.GetDesign, firstTopology, secondTopology, 0#, False, "tutorialAlignPlane1")
    
     
    Set ins = firstTopology.GetParent("DesignInstance")
    ins.AddMatingCondition abutPlanes
      
     
    helmObject.CommitCalls "AlignPlanes", False
         
    Dim bCloseFile As Boolean
    bCloseFile = part.Close("c:\wheelSpindleAssy.des", True)

End Function

Public Function line(vector1, vector2, sketch) As aLine

    Dim plane As aWorkplane
    Set plane = sketch.GetParent("Workplane")

    Dim localStart As zVector
    Dim localEnd As zVector

    'Get the local start and end vectors for the active workplane
    Set localStart = plane.Get3DVector(vector1)
    Set localEnd = plane.Get3DVector(vector2)

    Dim basicStrCls As BasicStraightClass
    Set basicStrCls = app.GetClass("BasicStraight")

    Dim curve As zCurve
    Set curve = basicStrCls.CreateBasicStraightTwoPoints(localStart, localEnd)

    Set line = sketch.CreateLine(curve)

End Function

Private Function AddComponent(pathName, part) As aDesignInstance
  
    Dim workplane As aWorkplane
    Set workplane = part.GetActiveWorkplane
    Dim component As aDesign
    Set component = part.OpenDesign(pathName)
    Dim translation As zMatrix
    Dim temp1 As zMatrix, temp2 As zMatrix
    
    Dim matrixCls As MatrixClass
    Set matrixCls = app.GetClass("Matrix")
    
    Set temp1 = matrixCls.CreateTranslationMatrix(workplane.GetLocalOrigin)
    Set temp2 = matrixCls.CreateRotationMatrix(workplane.GetLocalX, workplane.GetLocalY)
    Set translation = temp1.MultiplyByMatrix(temp2)
    
    Dim workplaneSet As ObjectSet
    Set workplaneSet = component.GetWorkplanes
    Dim Count As Integer
    Count = workplaneSet.GetCount
    
    Dim itCls As ItClass
    Set itCls = app.GetClass("It")
    
    Dim workplaneSetIt As Iterator
    Dim currentWorkplane As aWorkplane
    Set workplaneSetIt = itCls.CreateAObjectIt(workplaneSet)
    
    Dim temp3 As zMatrix
    Dim temp4 As zMatrix
    Dim oldMapping As zMatrix
    
    Dim str As String
    Set currentWorkplane = workplaneSetIt.start
    Do While workplaneSetIt.IsActive
        str = currentWorkplane.GetName
        If str = "base" Then
            Set temp3 = matrixCls.CreateTranslationMatrix(currentWorkplane.GetLocalOrigin)
            Set temp4 = matrixCls.CreateRotationMatrix(currentWorkplane.GetLocalX, currentWorkplane.GetLocalY)
            Set oldMapping = temp3.MultiplyByMatrix(temp4)
            Set translation = translation.MultiplyByMatrix(oldMapping.GetInverse)
            Exit Do
        End If
        Set currentWorkplane = workplaneSetIt.Next
    Loop
    
    Set AddComponent = part.GetDesign.CreateComponent(component, translation)

End Function
